home *** CD-ROM | disk | FTP | other *** search
/ Disc to the Future 2 / Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin / MAC / MPW_TOOL / TOOLS / TOOLS_WI / ICON_8 / ICONX_FO / LMISC.C < prev    next >
Text File  |  1990-03-02  |  14KB  |  572 lines
  1. /*
  2.  * File: lmisc.c
  3.  *  Contents: create, keywd, limit, llist
  4.  */
  5.  
  6. #include "::h:config.h"
  7. #include "::h:rt.h"
  8. #include "rproto.h"
  9. #include "::h:keyword.h"
  10. #include "::h:version.h"
  11.  
  12.  
  13. #ifdef PreProcess
  14. /* include(../M4/lib.m4) /* */
  15. /* */
  16. #endif                    /* PreProcess */
  17.  
  18. /*
  19.  * create - return an entry block for a co-expression.
  20.  */
  21.  
  22. OpBlock(create,1,"create",0)
  23.  
  24. Ocreate(entryp, cargp)
  25. word *entryp;
  26. register dptr cargp;
  27.    {
  28.  
  29. #ifdef Coexpr
  30.    register struct b_coexpr *sblkp;
  31.    register struct b_refresh *rblkp;
  32.    register dptr dp, ndp, dsp;
  33.    register word *newsp;
  34.    int na, nl, i;
  35.    struct b_proc *cproc;
  36.  
  37.    /*
  38.     * Get a new co-expression stack and initialize.
  39.     */
  40.    if ((sblkp = alccoexp()) == NULL) 
  41.       RunErr(0, NULL);
  42.  
  43.    /*
  44.     * Icon stack starts at word after co-expression stack block.  C stack
  45.     *  starts at end of stack region on machines with down-growing C stacks
  46.     *  and somewhere in the middle of the region.
  47.     *
  48.     * The C stack is aligned on a doubleword boundary.    For upgrowing
  49.     *  stacks, the C stack starts in the middle of the stack portion
  50.     *  of the static block.  For downgrowing stacks, the C stack starts
  51.     *  at the end of the static block.
  52.     */
  53.    newsp = (word *)((char *)sblkp + sizeof(struct b_coexpr));
  54.  
  55. #ifdef UpStack
  56.    sblkp->cstate[0] =
  57.       ((word)((char *)sblkp + (stksize - sizeof(*sblkp))/2)
  58.        &~(WordSize*StackAlign-1));
  59. #else                    /* UpStack */
  60.    sblkp->cstate[0] =
  61.     ((word)((char *)sblkp + stksize - WordSize)&~(WordSize*StackAlign-1));
  62. #endif                    /* UpStack */
  63.  
  64.    sblkp->es_argp = (dptr )newsp;
  65.    /*
  66.     * Calculate number of arguments and number of local variables.
  67.     *  na is nargs + 1 to include Arg0.
  68.     */
  69.    na = pfp->pf_nargs + 1;
  70.    cproc = (struct b_proc *)BlkLoc(argp[0]);
  71.    nl = (int)cproc->ndynam;
  72.  
  73.    /*
  74.     * Get a refresh block for the new co-expression.
  75.     */
  76.    if (blkreq((word)sizeof(struct b_refresh) +
  77.          (na + nl) * sizeof(struct descrip)) == Error) 
  78.       RunErr(0, NULL);
  79.    rblkp = alcrefresh(entryp, na, nl);
  80.    sblkp->freshblk.dword = D_Refresh;
  81.    BlkLoc(sblkp->freshblk) = (union block *) rblkp;
  82.  
  83.    /*
  84.     * Copy current procedure frame marker into refresh block.
  85.     */
  86.    rblkp->pfmkr = *pfp;
  87.    rblkp->pfmkr.pf_pfp = 0;
  88.  
  89.    /*
  90.     * Copy arguments into refresh block and onto new stack.
  91.     */
  92.    dp = &argp[0];
  93.    ndp = &rblkp->elems[0];
  94.    dsp = (dptr)newsp;
  95.    for (i = 1; i <= na; i++) {
  96.       *dsp++ = *dp;
  97.       *ndp++ = *dp++;
  98.       }
  99.  
  100.    /*
  101.     * Copy procedure frame to new stack and point dsp to word after frame.
  102.     */
  103.    *((struct pf_marker *)dsp) = *pfp;
  104.    sblkp->es_pfp = (struct pf_marker *)dsp;
  105.    sblkp->es_pfp->pf_pfp = 0;
  106.    dsp = (dptr)((word *)dsp + Vwsizeof(*pfp));
  107.    sblkp->es_ipc.opnd = entryp;
  108.    sblkp->es_gfp = 0;
  109.    sblkp->es_efp = 0;
  110.    sblkp->es_ilevel = 0;
  111.    sblkp->tvalloc = NULL;
  112.  
  113.    /*
  114.     * Copy locals to new stack and refresh block.
  115.     */
  116.    dp = &(pfp->pf_locals)[0];
  117.    for (i = 1; i <= nl; i++) {
  118.       *dsp++ = *dp;
  119.       *ndp++ = *dp++;
  120.       }
  121.    /*
  122.     * Push two null descriptors on the stack.
  123.     */
  124.    *dsp++ = nulldesc;
  125.    *dsp++ = nulldesc;
  126.  
  127.    sblkp->es_sp = (word *)dsp - 1;
  128.  
  129.    /*
  130.     * Return the new co-expression.
  131.     */
  132.    Arg0.dword = D_Coexpr;
  133.    BlkLoc(Arg0) = (union block *) sblkp;
  134.    Return;
  135. #else                    /* Coexpr */
  136.    RunErr(-401, NULL);
  137. #endif                    /* Coexpr */
  138.  
  139.    }
  140.  
  141. /*
  142.  * keywd - process keyword.
  143.  */
  144.  
  145. char *feattab[] = {
  146. #if AMIGA
  147.    "Amiga",
  148. #endif                    /* AMIGA */
  149. #if ATARI_ST
  150.    "Atari ST",
  151. #endif                    /* ATARI_ST */
  152. #if HIGHC_386
  153.    "MS-DOS/386",
  154. #endif                    /* HIGHC_386 */
  155. #if MACINTOSH
  156.    "Macintosh",
  157. #endif                    /* MACINTOSH */
  158. #if MSDOS
  159.    "MS-DOS",
  160. #endif                    /* MSDOS */
  161. #if MVS
  162.    "MVS",
  163. #endif                    /* MVS */
  164. #if OS2
  165.    "OS/2",
  166. #endif                    /* OS2 */
  167. #if PORT
  168.    "PORT",
  169. #endif                    /* PORT */
  170. #if UNIX
  171.    "UNIX",
  172. #endif                    /* VM */
  173. #if VMS
  174.    "VMS",
  175. #endif                    /* VMS */
  176. #if !EBCDIC
  177.    "ASCII",
  178. #else                    /* EBCDIC */
  179.    "EBCDIC",
  180. #endif                    /* EBCDIC */
  181. #ifdef IconCalling
  182.    "calling to Icon",
  183. #endif                    /* IconCalling */
  184. #ifdef Coexpr
  185.    "co-expressions",
  186. #endif                    /* Coexpr */
  187. #ifdef Header
  188.    "direct execution",
  189. #endif                    /* Header */
  190. #ifdef EnvVars
  191.    "environment variables",
  192. #endif                    /* EnvVars */
  193. #ifdef TraceBack
  194.    "error trace back",
  195. #endif                    /* TraceBack */
  196. #ifdef EvalTrace
  197.    "evaluation tracing",
  198. #endif                    /* EvalTrace */
  199. #ifdef ExecImages
  200.    "executable images",
  201. #endif                    /* ExecImages */
  202. #ifndef FixedRegions
  203.    "expandable regions",
  204. #endif                    /* FixedRegions */
  205. #ifdef ExternalFunctions
  206.    "external functions",
  207. #endif                    /* ExternalFunctions */
  208. #ifdef FixedRegions
  209.    "fixed regions",
  210. #endif                    /* FixedRegions */
  211. #ifdef KeyBoardFncs
  212.    "keyboard functions",
  213. #endif                    /* KeyBoardFncs */
  214. #ifdef LargeInts
  215.    "large integers",
  216. #endif                    /* LargeInts */
  217. #ifdef MathFncs
  218.    "math functions",
  219. #endif                    /* MathFncs */
  220. #ifdef MemMon
  221.    "memory monitoring",
  222. #endif                    /* MEMMON */
  223. #ifdef Pipes
  224.    "pipes",
  225. #endif                    /* Pipes */
  226. #ifdef StrInvoke
  227.    "string invocation",
  228. #endif                    /* StrInvoke */
  229. #ifdef SystemFnc
  230.    "system function",
  231. #endif                    /* SystemFnc */
  232. #ifdef DosFncs
  233.    "MS-DOS extensions",
  234. #endif                    /* DosFncs */
  235.    ""
  236.    };
  237.  
  238. LibDcl(keywd,0,"&keywd")
  239.    {
  240.    register int hour;
  241.    register word i;
  242.    register char *merid;
  243.    char **p;
  244.    char sbuf[MaxCvtLen];
  245.    extern word coll_stat, coll_str, coll_blk, coll_tot;
  246.    long runtim;
  247.    struct cal_time ct;
  248.  
  249. #if MACINTOSH && MPW
  250. /* #pragma unused(nargs) */
  251. #endif                    /* MACINTOSH && MPW */
  252.  
  253.    /*
  254.     * This is just plug and chug code.    For whatever keyword is desired,
  255.     *  the appropriate value is dug out of the system and made into
  256.     *  a suitable Icon value.
  257.     *
  258.     * A few special cases are worth noting:
  259.     *  &pos, &random, &trace - built-in trapped variables are returned
  260.     */
  261.    switch ((int)IntVal(Arg0)) {
  262.       case K_ASCII:
  263.          Arg0.dword = D_Cset;
  264.          BlkLoc(Arg0) = (union block *) &k_ascii;
  265.          break;
  266.       case K_CLOCK:
  267.          if (strreq((word)8) == Error) 
  268.             RunErr(0, NULL);
  269.          getitime(&ct);
  270.          sprintf(sbuf,"%02d:%02d:%02d", ct.hour, ct.minute, ct.second);
  271.          StrLen(Arg0) = 8;
  272.          StrLoc(Arg0) = alcstr(sbuf,(word)8);
  273.          break;
  274.       case K_COLLECTIONS:
  275.          MakeInt(coll_tot, &Arg0);
  276.          Suspend;
  277.          MakeInt(coll_stat, &Arg0);
  278.          Suspend;
  279.          MakeInt(coll_str, &Arg0);
  280.          Suspend;
  281.          MakeInt(coll_blk, &Arg0);
  282.          Return;
  283.  
  284.  
  285.       case K_CSET:
  286.          Arg0.dword = D_Cset;
  287.          BlkLoc(Arg0) = (union block *) &k_cset;
  288.          break;
  289.       case K_CURRENT:
  290.          Arg0 = k_current;
  291.          break;
  292.       case K_DATE:
  293.          if (strreq((word)10) == Error) 
  294.             RunErr(0, NULL);
  295.          getitime(&ct);
  296.          sprintf(sbuf, "%04d/%02d/%02d", ct.year, ct.month_no, ct.mday);
  297.          StrLen(Arg0) = 10;
  298.          StrLoc(Arg0) = alcstr(sbuf,(word)10);
  299.          break;
  300.       case K_DATELINE:
  301.          getitime(&ct);
  302.          if ((hour = ct.hour) >= 12) {
  303.             merid = "pm";
  304.             if (hour > 12)
  305.                hour -= 12;
  306.             }
  307.          else {
  308.             merid = "am";
  309.             if (hour < 1)
  310.                hour += 12;
  311.             }
  312.          sprintf(sbuf, "%s, %s %d, %d  %d:%02d %s", ct.wday, ct.month_nm,
  313.             ct.mday, ct.year, hour, ct.minute, merid);
  314.          if (strreq(i = strlen(sbuf)) == Error) 
  315.             RunErr(0, NULL);
  316.          StrLen(Arg0) = i;
  317.          StrLoc(Arg0) = alcstr(sbuf, i);
  318.          break;
  319.       case K_DIGITS:
  320.          Arg0.dword = D_Cset;
  321.          BlkLoc(Arg0) = (union block *)&k_digits;
  322.          break;
  323.  
  324.  
  325.       case K_ERROR:
  326.          Arg0.dword = D_Tvkywd;
  327.          BlkLoc(Arg0) = (union block *)&tvky_err;
  328.          break;
  329.  
  330.       case K_ERRORNUMBER:
  331.          if (k_errornumber == 0)
  332.             Fail;
  333.          MakeInt((k_errornumber > 0 ? k_errornumber : -k_errornumber), &Arg0);
  334.          break;
  335.       case K_ERRORTEXT:
  336.          if (k_errornumber == 0)
  337.             Fail;
  338.          StrLoc(Arg0) = k_errortext;
  339.          StrLen(Arg0) = strlen(k_errortext);
  340.          break;
  341.       case K_ERRORVALUE:
  342.          if (k_errornumber <= 0)
  343.             Fail;
  344.          Arg0 = k_errorvalue;
  345.          break;
  346.       case K_ERROUT:
  347.          Arg0.dword = D_File;
  348.          BlkLoc(Arg0) = (union block *)&k_errout;
  349.          break;
  350.       case K_FEATURES:
  351.          p = feattab;
  352.          for(;;) {
  353.             StrLen(Arg0) = strlen(*p);
  354.             if (StrLen(Arg0) == 0)
  355.                Fail;
  356.             StrLoc(Arg0) = *p;
  357.             Suspend;
  358.             p++;
  359.             }
  360.       case K_FILE:
  361.          StrLoc(Arg0) = findfile(ipc.opnd);
  362.          StrLen(Arg0) = strlen(StrLoc(Arg0));
  363.          break;
  364.  
  365.  
  366.       case K_HOST:
  367.          iconhost(sbuf);
  368.          if (strreq(i = strlen(sbuf)) == Error) 
  369.             RunErr(0, NULL);
  370.          StrLen(Arg0) = i;
  371.          StrLoc(Arg0) = alcstr(sbuf, i);
  372.          break;
  373.       case K_INPUT:
  374.          Arg0.dword = D_File;
  375.          BlkLoc(Arg0) = (union block *)&k_input;
  376.          break;
  377.       case K_LCASE:
  378.          Arg0.dword = D_Cset;
  379.          BlkLoc(Arg0) = (union block *)&k_lcase;
  380.          break;
  381.       case K_LETTERS:
  382.          Arg0.dword = D_Cset;
  383.          BlkLoc(Arg0) = (union block *)&k_letters;
  384.          break;
  385.       case K_LEVEL:
  386.          MakeInt(k_level, &Arg0);
  387.          break;
  388.       case K_LINE:
  389.          MakeInt(findline(ipc.opnd), &Arg0);
  390.          break;
  391.       case K_MAIN:
  392.          Arg0 = k_main;
  393.          break;
  394.       case K_OUTPUT:
  395.          Arg0.dword = D_File;
  396.          BlkLoc(Arg0) = (union block *)&k_output;
  397.          break;
  398.       case K_POS:
  399.          Arg0.dword = D_Tvkywd;
  400.          BlkLoc(Arg0) = (union block *) &tvky_pos;
  401.          break;
  402.       case K_RANDOM:
  403.          Arg0.dword = D_Tvkywd;
  404.          BlkLoc(Arg0) = (union block *) &tvky_ran;
  405.          break;
  406.       case K_REGIONS:
  407.  
  408. #ifdef FixedRegions
  409.          Arg0 = zerodesc;
  410. #else                    /* FixedRegions */
  411.          MakeInt(DiffPtrs(statend,statbase) - mstksize, &Arg0);
  412. #endif                    /* FixedRegions */
  413.  
  414.          Suspend;
  415.          MakeInt(DiffPtrs(strend,strbase), &Arg0);
  416.          Suspend;
  417.          MakeInt(DiffPtrs(blkend,blkbase), &Arg0);
  418.          Return;
  419.  
  420.       case K_SOURCE:
  421.  
  422. #ifndef Coexpr
  423.          Arg(0) = k_main;
  424. #else                    /* Coexpr */
  425.       Arg0.dword = D_Coexpr;
  426.       BlkLoc(Arg0) =
  427.             (union block *)topact((struct b_coexpr *)BlkLoc(k_current));
  428. #endif                    /* Coexpr */
  429.  
  430.          break;
  431.       case K_STORAGE:
  432.  
  433. #ifdef FixedRegions
  434.          Arg0 = zerodesc;
  435. #else                    /* FixedRegions */
  436.          MakeInt(DiffPtrs(statfree,statbase) - mstksize, &Arg0);
  437. #endif                    /* FixedRegions */
  438.  
  439.          Suspend;
  440.          MakeInt(DiffPtrs(strfree,strbase), &Arg0);
  441.          Suspend;
  442.          MakeInt(DiffPtrs(blkfree,blkbase), &Arg0);
  443.          Return;
  444.       case K_SUBJECT:
  445.          Arg0.dword = D_Tvkywd;
  446.          BlkLoc(Arg0) = (union block *) &tvky_sub;
  447.          break;
  448.       case K_TIME:
  449.          runtim = millisec();
  450.          MakeInt(runtim, &Arg0);
  451.          break;
  452.       case K_TRACE:
  453.          Arg0.dword = D_Tvkywd;
  454.          BlkLoc(Arg0) = (union block *)&tvky_trc;
  455.          break;
  456.       case K_UCASE:
  457.          Arg0.dword = D_Cset;
  458.          BlkLoc(Arg0) = (union block *)&k_ucase;
  459.          break;
  460.       case K_VERSION:
  461.          if (strreq(i = strlen(Version)) == Error) 
  462.             RunErr(0, NULL);
  463.          StrLen(Arg0) = i;
  464.          StrLoc(Arg0) = Version;
  465.          break;
  466.       default:
  467.          syserr("keyword: unknown keyword type.");
  468.       }
  469.    Return;
  470.    }
  471.  
  472.  
  473. /*
  474.  * limit - explicit limitation initialization.
  475.  */
  476.  
  477.  
  478. #ifdef WATERLOO_C_V3_0
  479. struct b_iproc Blimit = {
  480.     T_Proc,
  481.     Vsizeof(struct b_proc),
  482.     Olimit,
  483.     2,
  484.     -1,
  485.     0,
  486.     0,
  487.     {sizeof(BackSlash)-1,BackSlash}}; Olimit(nargs,cargp,sptr) register dptr cargp;
  488. #else                    /* WATERLOO_C_V3_0 */
  489. LibDcl(limit,2,BackSlash)
  490. #endif                    /* WATERLOO_C_V3_0 */
  491.  
  492.    {
  493.  
  494. #if MACINTOSH
  495. #if MPW
  496. /* #pragma unused(nargs) */
  497. #endif                    /* MPW */
  498. #endif                    /* MACINTOSH */
  499.  
  500.    /*
  501.     * The limit is both passed and returned in Arg0.  The limit must
  502.     *  be an integer.  If the limit is 0, the expression being evaluated
  503.     *  fails.  If the limit is < 0, it is an error.  Note that the
  504.     *  result produced by limit is ultimately picked up by the lsusp
  505.     *  function.
  506.     */
  507.    if (DeRef(Arg0) == Error) 
  508.       RunErr(0, NULL);
  509.  
  510.    switch (cvint(&Arg0)) {
  511.  
  512.       case T_Integer:
  513.          break;
  514.  
  515.       default:
  516.          RunErr(101, &Arg0);
  517.       }
  518.  
  519.    if (IntVal(Arg0) < 0) 
  520.       RunErr(205, &Arg0);
  521.    if (IntVal(Arg0) == 0)
  522.       Fail;
  523.    Return;
  524.    }
  525.  
  526.  
  527. /*
  528.  * [ ... ] - create an explicitly specified list.
  529.  */
  530.  
  531. LibDcl(llist,-1,"[...]")
  532.    {
  533.    register word i;
  534.    register struct b_list *hp;
  535.    register struct b_lelem *bp;
  536.    word nslots;
  537.  
  538.    nslots = nargs;
  539.    if (nslots == 0)
  540.       nslots = MinListSlots;
  541.  
  542.    if (blkreq((word)sizeof(struct b_list) + sizeof(struct b_lelem) +
  543.          nslots * sizeof(struct descrip)) == Error) 
  544.       RunErr(0, NULL);
  545.  
  546.    /*
  547.     * Allocate the list and a list block.
  548.     */
  549.    hp = alclist((word)nargs);
  550.    bp = alclstb(nslots, (word)0, (word)nargs);
  551.  
  552.    /*
  553.     * Make the list block just allocated into the first and last blocks
  554.     *  for the list.
  555.     */
  556.    hp->listhead = hp->listtail = (union block *)bp;
  557.    /*
  558.     * Dereference each argument in turn and assign it to a list element.
  559.     */
  560.    for (i = 1; i <= nargs; i++) {
  561.       if (DeRef(Arg(i)) == Error) 
  562.          RunErr(0, NULL);
  563.       bp->lslots[i-1] = Arg(i);
  564.       }
  565.    /*
  566.     * Point Arg0 at the new list and return it.
  567.     */
  568.    ArgType(0) = D_List;
  569.    Arg(0).vword.bptr = (union block *)hp;
  570.    Return;
  571.    }
  572.